Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/C/Applications/Moscow ML 1.42/e_SML/copyrelease.sml

Text File | 1996-07-23 | 7.4 KB | 267 lines | [TEXT/Moml]

(* copyrelease.sml *)
(* 23Jul96 ----- e *)

load "Nonstdio"; load "FileSys"; load "Path"; load "Binaryset";

open FileSys;

exception Diff of string;

val buf_limit = 32768;

local
  prim_eqtype buffer_
  prim_val buffer_    : int -> buffer_ = 1 "create_string";
  prim_val magic      : 'a -> 'b = 1 "identity";
  prim_val fromCA     : CharArray.array -> buffer_ ref = 1 "identity";
  prim_val sub_       : buffer_ -> int -> char         = 2 "get_nth_char";

  fun make_buffer__ len = ref (buffer_ len)
in

val make_buffer : int -> CharArray.array =  magic make_buffer__

(* compare files *)

fun compare_file_guts s1 s2 =
   let val z1 = Nonstdio.in_stream_length s1
       val z2 = Nonstdio.in_stream_length s2
   in if z1 <> z2 then raise Diff "size" else
     let
       val b1 = make_buffer (if z1 > buf_limit then buf_limit else z1)
       val b2 = make_buffer (if z2 > buf_limit then buf_limit else z2)
       val ref b1' = fromCA b1
       val ref b2' = fromCA b2
       fun comp_bufs n =
         if n < 0 then ()
         else if (sub_ b1' n) = (sub_ b2' n)
              then comp_bufs (n-1)
              else raise Diff "diff"
       fun comp_chunk x =
         let val nxx = x + buf_limit
             val nxc = if nxx > z1 then z1 else nxx
             val csz = nxc - x
         in if csz <= 0 then ()
            else ( Nonstdio.buff_input s1 b1 0 csz;
                   Nonstdio.buff_input s2 b2 0 csz;
                   comp_bufs (csz-1);
                   comp_chunk nxc )
         end
     in comp_chunk 0
     end
   end

end
;

fun compare_files src tgt =
   let val is = BasicIO.open_in_bin src
   in let val os = BasicIO.open_in_bin tgt
      in
         (if modTime src <> modTime tgt
          then raise Diff "time"
          else ();
          compare_file_guts is os;
          BasicIO.close_in is;
          BasicIO.close_in os)
         handle x => (BasicIO.close_in os; raise x)
      end
      handle x => (BasicIO.close_in is; raise x)
   end
;

(* copy files *)

fun copy_file_guts is os =
   let val sz = Nonstdio.in_stream_length is
       val bf = make_buffer (if sz > buf_limit then buf_limit else sz)
       fun copy_chunk x =
         let val nxx = x + buf_limit
             val nxc = if nxx > sz then sz else nxx
             val csz = nxc - x
         in if csz <= 0 then ()
            else ( Nonstdio.buff_input  is bf 0 csz;
                   Nonstdio.buff_output os bf 0 csz;
                   copy_chunk nxc )
         end
   in copy_chunk 0
   end
;

fun copy_bin_file src tgt =
   let val is = BasicIO.open_in_bin src
   in let val os = BasicIO.open_out_bin tgt
      in
         (copy_file_guts is os;
          BasicIO.close_in is;
          BasicIO.close_out os;
          setTime (tgt, SOME (modTime src)))
         handle x => (BasicIO.close_out os; remove tgt; raise x)
      end
      handle x => (BasicIO.close_in is; raise x)
   end
;

fun copy_txt_file src tgt =
   let val is = BasicIO.open_in src
   in let val os = BasicIO.open_out tgt
      in
         (copy_file_guts is os;
          BasicIO.close_in is;
          BasicIO.close_out os;
          setTime (tgt, SOME (modTime src)))
         handle x => (BasicIO.close_out os; remove tgt; raise x)
      end
      handle x => (BasicIO.close_in is; raise x)
   end
;

local
fun option_compare (NONE  ,  NONE)  = EQUAL
  | option_compare (NONE  ,     _)  = LESS
  | option_compare (     _,  NONE)  = GREATER
  | option_compare (SOME a,SOME b)  = String.compare (a,b)
in
val bins = Binaryset.addList
           ((Binaryset.empty option_compare),
           [      SOME "ui", SOME "uo" ])
val objs = Binaryset.addList
           ((Binaryset.empty option_compare),
           [NONE, SOME "ui", SOME "uo", SOME "sig"])
val txts = Binaryset.addList
           ((Binaryset.empty option_compare),
           [SOME "sml", SOME "sig", SOME "mlp", SOME "fke",
            SOME "grm", SOME "lex", SOME "txt"])
end;

fun copy_file_for_ext ext =
   if Binaryset.member (txts,ext)
   then copy_txt_file
   else copy_bin_file
;

fun ensure_dir tgt =
  if access (tgt,[])
  then raise Fail ("Target directory: '" ^ tgt ^ "' already exists!")
  else mkDir tgt
;

fun copy_dir_filtered ffun src tgt =
  let val _ = ensure_dir tgt
      val dir = openDir src
      val _   =   chDir src
      fun copy_file fname =
        let val {base, ext} = Path.splitBaseExt fname
            val tname = Path.joinDirFile {dir = tgt, file = fname }
        in if isDir fname
           then () (* do nested dirs? *)
           else if ffun base ext
           then copy_file_for_ext ext fname tname
           else ()
        end
      fun copy "" = ()
        | copy f  = ( copy_file f ; copy (readDir dir) )
  in
     let val _ = copy (readDir dir)
     in closeDir dir
     end
     handle exn as OS.SysErr (msg, _) => (closeDir dir; raise exn)
  end
;

fun compare_dirs_filtered ffun src tgt =
  let val dir = openDir src
      val _   =   chDir src
      val result = ref true
      fun comp_file fname =
        let val {base, ext} = Path.splitBaseExt fname
            val tname = Path.joinDirFile {dir = tgt, file = fname }
        in if isDir fname
           then () (* do nested dirs? *)
           else if ffun base ext
           then compare_files fname tname
           else ()
        end
        handle e as Diff s =>
          ( if !moolevel > 1
            then (print s; print " "; print fname; print "\n")
            else ();
            result := false )
      fun comp "" = ()
        | comp f  = ( comp_file f ; comp (readDir dir) )
  in
     let val _ = comp (readDir dir)
     in closeDir dir; !result
     end
     handle exn as OS.SysErr (msg, _) => (closeDir dir; raise exn)
  end
;

(* deleting a file in the current dir screws readDir (it skips names)
fun clean_dir_filtered ffun tgt =
  let val dir = openDir tgt
      val _   =   chDir tgt
      fun delf_file fname =
        let val {base, ext} = Path.splitBaseExt fname
        in if isDir fname
           then () (* do nested dirs? *)
           else if ffun base ext
           then remove fname
           else ()
        end
      fun delf "" = ()
        | delf f  = ( delf_file f ; delf (readDir dir) )
  in
     let val _ = delf (readDir dir)
     in closeDir dir
     end
     handle exn as OS.SysErr (msg, _) => (closeDir dir; raise exn)
  end
;
*)
fun clean_dir_filtered ffun tgt =
  let val dir = openDir tgt
      val _   =   chDir tgt
      val nms = ref []
      fun delf_file fname =
        let val {base, ext} = Path.splitBaseExt fname
        in if isDir fname
           then () (* do nested dirs? *)
           else if ffun base ext
           then nms := fname :: (!nms)
           else ()
        end
      fun delf "" = ()
        | delf f  = ( delf_file f ; delf (readDir dir) )
  in
     let val _ = delf (readDir dir)
     in List.app remove (!nms); closeDir dir
     end
     handle exn as OS.SysErr (msg, _) => (closeDir dir; raise exn)
  end
;

fun no_filt _ _ = true;

fun lib_filt _ ext = Binaryset.member(objs,ext);

fun bin_filt _ ext = Binaryset.member(bins,ext);

val clean_dir_bin = clean_dir_filtered bin_filt;

val copy_dir = copy_dir_filtered no_filt;

val copy_dir_obj = copy_dir_filtered lib_filt;

val compare_dirs = compare_dirs_filtered no_filt;

val compare_dirs_obj = compare_dirs_filtered lib_filt;

(*
clean_dir_bin (home ^ "src:mosmllib:");
clean_dir_bin (home ^ "src:compiler:");
clean_dir_bin (home ^ "src:lex:");
clean_dir_bin (home ^ "src:toolssrc:");
copy_dir_obj (home ^ "src:mosmllib:") (home ^ "lib2:");
compare_dirs_obj (home ^ "src:mosmllib:") (home ^ "lib2:");
*)